home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / structures / HanoïDisk < prev    next >
Encoding:
Text File  |  1988-05-28  |  3.6 KB  |  95 lines  |  [TEXT/CCL ]
  1. ; Ted Kaehler and Dave Patterson: a taste of SmallTalk
  2. ; W. W. Norton ed., chapter 5, pp. 65 ff.
  3. ; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
  4. ; © Copyright 1988 Jean-Pascal J. LANGE.
  5.  
  6. (proclaim '(optimize (speed 3)
  7.             (space 0)
  8.             (safety 0)
  9.             (compilation-speed 0) ))
  10.  
  11. (defStruct HanoiDisk
  12. ; Each disk in the game is represented by an object of structure
  13. ; HanoiDisk. It has
  14. ;   name: name of this disk (a character),
  15. ;   width: size of the disk (1 is the smallest disk width),
  16. ;   pole: number telling which pole the disk is on,
  17. ;   diskRectangle: a rectangle on the screen that the disk occupies.
  18.   (name nil)
  19.   (width nil)
  20.   (pole nil)
  21.   (diskRectangle nil) )
  22.  
  23. ; access
  24.  
  25. (deFun pole (thisDisk) ; return which pole this disk is on
  26.   (HanoiDisk-pole thisDisk) )
  27.  
  28. (deFun name (thisDisk) ; return the name of this disk
  29.   (HanoiDisk-name thisDisk) )
  30.  
  31. (deFun whichTowers (aTowerOfHanoi)
  32. ; There are three global variables shared across the whole game:
  33. ;       *TheTowers*: the structure that represents the whole game and
  34. ;                    holds the stacks of disks,
  35. ;       *Thickness*: the thickness of a disk in screen dots,
  36. ;       *DiskGap*: the number of screen dots between disks in a stack.
  37.   (declare (special *TheTowers* *Thickness* *DiskGap*))
  38.   ; install the structure representing the towers
  39.   (setq *TheTowers* aTowerOfHanoi)
  40.   (setq *Thickness* 14) ; thickness of a disk in screen dots
  41.   (setq *DiskGap* 2) )  ; distance between disks
  42.  
  43. (deFun widthPole (thisDisk size whichPole)
  44.   (declare (special *TheTowers* *Thickness* *DiskGap*))
  45.   ; set the values for this disk
  46.   (setf (HanoiDisk-width thisDisk) size)
  47.   (setf (HanoiDisk-pole thisDisk) whichPole)
  48.   ; compute the center of the disk on the screen
  49.   (let* ((where)
  50.          (window-size (ask (front-window) (window-size)))
  51.          (window-height (point-v window-size))
  52.          (window-width (point-h window-size))
  53.          (x0 (floor window-width 6))
  54.          (y0 (- window-height 11))
  55.          (h-distance (floor window-width 3)) )
  56.     (cond ((not (>= size 1000))
  57.            ; a normal disk
  58.            (setf (HanoiDisk-name thisDisk)
  59.                  (code-char (+ (char-code #\A) (1- size))) )
  60.            (let ((y (- y0 (* (- (howMany *TheTowers*) size)
  61.                              (+ *Thickness* *DiskGap*) ))))
  62.              (setq where (make-point x0 y)) ) )
  63.           (t (setf (HanoiDisk-name thisDisk) 'm) ; a mock disk
  64.              (setq where
  65.                    (make-point (- (* h-distance whichPole) x0)
  66.                                (+ y0 *Thickness* *DiskGap*) ) ) ) )
  67.     ; create the rectangle, specify its size and locate its center
  68.     (let ((extent (make-point (* size 14) *Thickness*)))
  69.       (setf (HanoiDisk-diskRectangle thisDisk)
  70.             (originExtent #@(0 0) extent)) )
  71.     ; locate the rectangle center
  72.     (setCenter (HanoiDisk-diskRectangle thisDisk) where)) )
  73.  
  74. (deFun centerDisk (thisDisk)
  75. ; returns a point that is the current center of this disk
  76.   (center (HanoiDisk-diskRectangle thisDisk)) )
  77.  
  78. (deFun moveUpon (thisDisk destination)
  79. ; this disk just moved. Record the new pole and tell the user.
  80.   (declare (special *Thickness* *DiskGap*))
  81.   (setf (HanoiDisk-pole thisDisk) (pole destination))
  82.   ; remove the old image
  83.   (invert thisDisk)
  84.   ; reposition
  85.   (let ((point (make-point 0 (+ *Thickness* *DiskGap*))))
  86.     (setCenter (HanoiDisk-diskRectangle thisDisk)
  87.                (subtract-points (centerDisk destination) point )) )
  88.   ; display the new one
  89.   (invert thisDisk) )
  90.  
  91. (deFun invert (thisDisk)
  92. ; shows a disk on the screen by turning white to black
  93. ; in a rectangular region
  94.   (invertRect (HanoiDisk-diskRectangle thisDisk)) )
  95.